home *** CD-ROM | disk | FTP | other *** search
/ Hardcore Visual Basic 5.0 (2nd Edition) / Hardcore Visual Basic 5.0 - Second Edition (1997)(Microsoft Press).iso / Code / Utility.bas < prev    next >
BASIC Source File  |  1997-06-14  |  28KB  |  906 lines

  1. Attribute VB_Name = "MUtility"
  2. Option Explicit
  3.  
  4. Public Enum EHexDump
  5.     ehdOneColumn
  6.     ehdTwoColumn
  7.     ehdEndless
  8.     ehdSample8
  9.     ehdSample16
  10. End Enum
  11.  
  12. Enum ESearchOptions
  13.     esoCaseSense = &H1
  14.     esoBackward = &H2
  15.     esoWholeWord = &H4
  16. End Enum
  17.  
  18. Public Enum EErrorUtility
  19.     eeBaseUtility = 13000   ' Utility
  20.     eeNoMousePointer        ' HourGlass: Object doesn't have mouse pointer
  21.     eeNoTrueOption          ' GetOption: None of the options are True
  22.     eeNotOptionArray        ' GetOption: Not control array of OptionButton
  23.     eeMissingParameter      ' InStrR: One or more parameters are missing
  24. End Enum
  25.  
  26. #If fComponent Then
  27. Private Sub Class_Initialize()
  28.     ' Seed sequence with timer for each client
  29.     Randomize
  30. End Sub
  31. #End If
  32.  
  33. #If fComponent = 0 Then
  34. Private Sub ErrRaise(e As Long)
  35.     Dim sText As String, sSource As String
  36.     If e > 1000 Then
  37.         sSource = App.ExeName & ".Utility"
  38.         Select Case e
  39.         Case eeBaseUtility
  40.             BugAssert True
  41.         Case eeNoMousePointer
  42.             sText = "HourGlass: Object doesn't have mouse pointer"
  43.         Case eeNoTrueOption
  44.             sText = "GetOption: None of the options are True"
  45.         Case eeNotOptionArray
  46.             sText = "GetOption: Argument is not a control array" & _
  47.                     "of OptionButtons"
  48.         Case eeMissingParameter
  49.             sText = "InStrR: One or more parameters are missing"
  50.         End Select
  51.         Err.Raise COMError(e), sSource, sText
  52.     Else
  53.         ' Raise standard Visual Basic error
  54.         sSource = App.ExeName & ".VBError"
  55.         Err.Raise e, sSource
  56.     End If
  57. End Sub
  58. #End If
  59.  
  60. ' Can't do sNullChr in type library, so fake it here
  61. Public Property Get sNullChr() As String
  62.     sNullChr = vbNullChar
  63. End Property
  64.  
  65. Sub HourGlass(obj As Object)
  66.     Static ordMouse As Integer, fOn As Boolean
  67.     On Error Resume Next
  68.     If Not fOn Then
  69.         ' Save pointer and set hourglass
  70.         ordMouse = obj.MousePointer
  71.         obj.MousePointer = vbHourglass
  72.         fOn = True
  73.     Else
  74.         ' Restore pointer
  75.         obj.MousePointer = ordMouse
  76.         fOn = False
  77.     End If
  78.     If Err Then ErrRaise eeNoMousePointer
  79. End Sub
  80.  
  81. Function IsArrayEmpty(va As Variant) As Boolean
  82.     Dim v As Variant
  83.     On Error Resume Next
  84.     v = va(LBound(va))
  85.     IsArrayEmpty = (Err <> 0)
  86. End Function
  87.  
  88. Function HasShell() As Boolean
  89.     Dim dw As Long
  90.     dw = GetVersion()
  91.     If (dw And &HFF&) >= 4 Then
  92.         HasShell = True
  93.         ' Proves that operating system has shell, but not
  94.         ' necessarily that it is installed. Some might argue
  95.         ' that this function should check Registry under WinNT
  96.         ' or SYSTEM.INI Shell= under Win95
  97.     End If
  98. End Function
  99.  
  100. Function IsNT() As Boolean
  101.     Dim dw As Long
  102.     IsNT = ((GetVersion() And &H80000000) = 0)
  103. End Function
  104.  
  105. Sub SwapBytes(ByVal b1 As Byte, ByVal b2 As Byte)
  106.     Dim bTmp As Byte
  107.     b1 = bTmp
  108.     b2 = b1
  109.     b1 = bTmp
  110. End Sub
  111.  
  112. Sub SwapIntegers(ByVal w1 As Integer, ByVal w2 As Integer)
  113.     Dim wTmp As Byte
  114.     w1 = wTmp
  115.     w2 = w1
  116.     w1 = wTmp
  117. End Sub
  118.  
  119. Sub SwapLongs(ByVal dw1 As Long, ByVal dw2 As Long)
  120.     Dim dwTmp As Byte
  121.     dw1 = dwTmp
  122.     dw2 = dw1
  123.     dw1 = dwTmp
  124. End Sub
  125.  
  126. Function FmtHex(ByVal i As Long, _
  127.                 Optional ByVal iWidth As Integer = 8) As String
  128.     FmtHex = Right$(String$(iWidth, "0") & Hex$(i), iWidth)
  129. End Function
  130.  
  131. Function FmtInt(ByVal iVal As Integer, ByVal iWidth As Integer, _
  132.                 Optional fRight As Boolean = True) As String
  133.     If fRight Then
  134.         FmtInt = Right$(Space$(iWidth) & iVal, iWidth)
  135.     Else
  136.         FmtInt = Left$(iVal & Space$(iWidth), iWidth)
  137.     End If
  138. End Function
  139.  
  140. Function FmtStr(s As String, ByVal iWidth As Integer, _
  141.                 Optional fRight As Boolean = True) As String
  142.     If fRight Then
  143.         FmtStr = Left$(s & Space$(iWidth), iWidth)
  144.     Else
  145.         FmtStr = Right$(Space$(iWidth) & s, iWidth)
  146.     End If
  147. End Function
  148.  
  149. ' Find the True option from a control array of OptionButtons
  150. Function GetOption(opts As Object) As Integer
  151.     On Error GoTo GetOptionFail
  152.     Dim opt As OptionButton
  153.     For Each opt In opts
  154.         If opt.Value Then
  155.             GetOption = opt.Index
  156.             Exit Function
  157.         End If
  158.     Next
  159.     On Error GoTo 0
  160.     ErrRaise eeNoTrueOption
  161.     Exit Function
  162. GetOptionFail:
  163.     ErrRaise eeNotOptionArray
  164. End Function
  165.  
  166. ' Make sure path ends in a backslash
  167. Function NormalizePath(sPath As String) As String
  168.     If Right$(sPath, 1) <> sBSlash Then
  169.         NormalizePath = sPath & sBSlash
  170.     Else
  171.         NormalizePath = sPath
  172.     End If
  173. End Function
  174.  
  175. ' Make sure path doesn't end in a backslash
  176. Sub DenormalizePath(sPath As Variant)
  177.     If Right$(sPath, 1) = sBSlash Then
  178.         sPath = Left$(sPath, Len(sPath) - 1)
  179.     End If
  180. End Sub
  181.  
  182. ' Test file existence with error trapping
  183. Function ExistFile(sSpec As String) As Boolean
  184.     On Error Resume Next
  185.     Call FileLen(sSpec)
  186.     ExistFile = (Err = 0)
  187. End Function
  188.  
  189. ' Test file existence with the Windows API
  190. Function ExistFileDir(sSpec As String) As Boolean
  191.     Dim af As Long
  192.     af = GetFileAttributes(sSpec)
  193.     ExistFileDir = (af <> -1)
  194. End Function
  195.  
  196. ' Test file existence with the Dir$ function
  197. Function Exists(sSpec As String) As Boolean
  198.     Exists = Dir$(sSpec, vbDirectory) <> sEmpty
  199. End Function
  200.  
  201. ' Convert Automation color to Windows color
  202. Function TranslateColor(ByVal clr As OLE_COLOR, _
  203.                         Optional hPal As Long = 0) As Long
  204.     If OleTranslateColor(clr, hPal, TranslateColor) Then
  205.         TranslateColor = CLR_INVALID
  206.     End If
  207. End Function
  208.  
  209. Function GetExtPos(sSpec As String) As Integer
  210.     Dim iLast As Integer, iExt As Integer
  211.     iLast = Len(sSpec)
  212.     
  213.     ' Parse backward to find extension or base
  214.     For iExt = iLast + 1 To 1 Step -1
  215.         Select Case Mid$(sSpec, iExt, 1)
  216.         Case "."
  217.             ' First . from right is extension start
  218.             Exit For
  219.         Case "\"
  220.             ' First \ from right is base start
  221.             iExt = iLast + 1
  222.             Exit For
  223.         End Select
  224.     Next
  225.  
  226.     ' Negative return indicates no extension, but this
  227.     ' is base so callers don't have to reparse.
  228.     GetExtPos = iExt
  229. End Function
  230.  
  231. Function GetFileText(sFileName As String) As String
  232.     Dim nFile As Integer, sText As String
  233.     nFile = FreeFile
  234.     'Open sFileName For Input As nFile ' Don't do this!!!
  235.     If Not ExistFile(sFileName) Then ErrRaise eeFileNotFound
  236.     ' Let others read but not write
  237.     Open sFileName For Binary Access Read Lock Write As nFile
  238.     ' sText = Input$(LOF(nFile), nFile) ! Don't do this!!!
  239.     ' This is much faster
  240.     sText = String$(LOF(nFile), 0)
  241.     Get nFile, 1, sText
  242.     Close nFile
  243.     GetFileText = sText
  244. End Function
  245.  
  246. Function IsRTF(sFileName As String) As Boolean
  247.     Dim nFile As Integer, sText As String
  248.     nFile = FreeFile
  249.     If Not ExistFile(sFileName) Then Exit Function
  250.     ' Pass error through to caller
  251.     Open sFileName For Binary Access Read Lock Write As nFile
  252.     If LOF(nFile) < 5 Then Exit Function
  253.     sText = String$(5, 0)
  254.     Get nFile, 1, sText
  255.     Close nFile
  256.     If sText = "{\rtf" Then IsRTF = True
  257. End Function
  258.  
  259. Function GetRandom(ByVal iLo As Long, ByVal iHi As Long) As Long
  260.     GetRandom = Int(iLo + (Rnd * (iHi - iLo + 1)))
  261. End Function
  262.  
  263. Sub DoWaitEvents(msWait As Long)
  264.     Dim msEnd As Long
  265.     msEnd = GetTickCount + msWait
  266.     Do
  267.         DoEvents
  268.     Loop While GetTickCount < msEnd
  269. End Sub
  270.  
  271. Function HexDumpS(s As String, Optional ehdFmt As EHexDump = ehdOneColumn) As String
  272.     Dim ab() As Byte
  273.     ab = StrToStrB(s)
  274.     HexDumpS = HexDump(ab, ehdFmt)
  275. End Function
  276.  
  277. Function HexDumpB(s As String, Optional ehdFmt As EHexDump = ehdOneColumn) As String
  278.     Dim ab() As Byte
  279.     ab = s
  280.     HexDumpB = HexDump(ab, ehdFmt)
  281. End Function
  282.  
  283. Function HexDumpPtr(ByVal p As Long, ByVal c As Long, _
  284.                     Optional ehdFmt As EHexDump = ehdOneColumn) As String
  285.     Dim ab() As Byte
  286.     ReDim ab(0 To c - 1) As Byte
  287.     CopyMemory ab(0), ByVal p, c
  288.     HexDumpPtr = HexDump(ab, ehdFmt)
  289. End Function
  290.  
  291. Function HexDump(ab() As Byte, _
  292.                  Optional ehdFmt As EHexDump = ehdOneColumn) As String
  293.     Dim i As Integer, sDump As String, sAscii As String
  294.     Dim iColumn As Integer, iCur As Integer, sCur As String
  295.     Dim sLine As String
  296.     Select Case ehdFmt
  297.     Case ehdOneColumn, ehdSample8
  298.         iColumn = 8
  299.     Case ehdTwoColumn, ehdSample16
  300.         iColumn = 16
  301.     Case ehdEndless
  302.         iColumn = 32767
  303.     End Select
  304.  
  305.     For i = LBound(ab) To UBound(ab)
  306.         ' Get current character
  307.         iCur = ab(i)
  308.         sCur = Chr$(iCur)
  309.  
  310.         ' Append its hex value
  311.         sLine = sLine & Right$("0" & Hex$(iCur), 2) & " "
  312.  
  313.         ' Append its ASCII value or dot
  314.         If ehdFmt <= ehdTwoColumn Then
  315.             If iCur >= 32 And iCur < 127 Then
  316.                 sAscii = sAscii & sCur
  317.             Else
  318.                 sAscii = sAscii & "."
  319.             End If
  320.         End If
  321.         
  322.         ' Append ASCII to dump and wrap every paragraph
  323.         If (i + 1) Mod 8 = 0 Then sLine = sLine & " "
  324.         If (i + 1) Mod iColumn = 0 Then
  325.             If ehdFmt >= ehdSample8 Then
  326.                 sLine = sLine & "..."
  327.                 Exit For
  328.             End If
  329.             sLine = sLine & " " & sAscii & sCrLf
  330.             sDump = sDump & sLine
  331.             sAscii = sEmpty
  332.             sLine = sEmpty
  333.         End If
  334.     Next
  335.     
  336.     If ehdFmt <= ehdTwoColumn Then
  337.         If (i + 1) Mod iColumn Then
  338.             If ehdFmt Then
  339.                 sLine = Left$(sLine & Space$(53), 53) & sAscii
  340.             Else
  341.                 sLine = Left$(sLine & Space$(26), 26) & sAscii
  342.             End If
  343.         End If
  344.         sDump = sDump & sLine
  345.     Else
  346.         sDump = sLine
  347.     End If
  348.     HexDump = sDump
  349.  
  350. End Function
  351.  
  352. Function StrToStrB(ByVal s As String) As String
  353.     If UnicodeTypeLib Then
  354.         StrToStrB = s
  355.     Else
  356.         StrToStrB = StrConv(s, vbFromUnicode)
  357.     End If
  358. End Function
  359.  
  360. Function StrBToStr(ByVal s As String) As String
  361.     If UnicodeTypeLib Then
  362.         StrBToStr = s
  363.     Else
  364.         StrBToStr = StrConv(s, vbUnicode)
  365.     End If
  366. End Function
  367.  
  368. Function StrZToStr(s As String) As String
  369.     StrZToStr = Left$(s, lstrlen(s))
  370. End Function
  371.  
  372. Function ExpandEnvStr(sData As String) As String
  373.     Dim c As Long, s As String
  374.     ' Get the length
  375.     s = sEmpty ' Needed to get around Windows 95 limitation
  376.     c = ExpandEnvironmentStrings(sData, s, c)
  377.     ' Expand the string
  378.     s = String$(c - 1, 0)
  379.     c = ExpandEnvironmentStrings(sData, s, c)
  380.     ExpandEnvStr = s
  381. End Function
  382.  
  383. Function PointerToString(p As Long) As String
  384.     Dim c As Long
  385.     c = lstrlenPtr(p)
  386.     PointerToString = String$(c, 0)
  387.     If UnicodeTypeLib Then
  388.         CopyMemoryToStr PointerToString, ByVal p, c * 2
  389.     Else
  390.         CopyMemoryToStr PointerToString, ByVal p, c
  391.     End If
  392. End Function
  393.  
  394. Function StringToPointer(s As String) As Long
  395.     If UnicodeTypeLib Then
  396.         StringToPointer = VarPtr(s)
  397.     Else
  398.         StringToPointer = StrPtr(s)
  399.     End If
  400. End Function
  401.  
  402. Sub SaveFileStr(sFile As String, sContent As String)
  403.     Dim nFile As Integer
  404.     nFile = FreeFile
  405.     Open sFile For Output Access Write Lock Write As nFile
  406.     Print #nFile, sContent;
  407.     Close nFile
  408. End Sub
  409.  
  410. Function SaveFileText(sFileName As String, sText As String) As Long
  411.     Dim nFile As Integer
  412.     On Error Resume Next
  413.     nFile = FreeFile
  414.     Open sFileName For Output Access Write Lock Write As nFile
  415.     Print #nFile, sText
  416.     Close nFile
  417.     SaveFileText = Err
  418. End Function
  419.  
  420. Function FindString(sTarget As String, sFind As String, _
  421.                     Optional ByVal iPos As Long, _
  422.                     Optional ByVal esoOptions As ESearchOptions) As Long
  423.     Dim ordComp As Long, cFind As Long, fBack As Boolean
  424.     ' Get the compare method
  425.     If esoOptions And esoCaseSense Then
  426.         ordComp = vbBinaryCompare
  427.     Else
  428.         ordComp = vbTextCompare
  429.     End If
  430.     ' Set up first search
  431.     cFind = Len(sFind)
  432.     If iPos = 0 Then iPos = 1
  433.     If esoOptions And esoBackward Then fBack = True
  434.     Do
  435.         ' Find the string
  436.         If fBack Then
  437.             iPos = InStrR(iPos, sTarget, sFind, ordComp)
  438.         Else
  439.             iPos = InStr(iPos, sTarget, sFind, ordComp)
  440.         End If
  441.         ' If not found, we're done
  442.         If iPos = 0 Then Exit Function
  443.         If esoOptions And esoWholeWord Then
  444.             ' If it's supposed to be whole word and is, we're done
  445.             If IsWholeWord(sTarget, iPos, Len(sFind)) Then Exit Do
  446.             ' Otherwise, set up next search
  447.             If fBack Then
  448.                 iPos = iPos - cFind
  449.                 If iPos < 1 Then Exit Function
  450.             Else
  451.                 iPos = iPos + cFind
  452.                 If iPos > Len(sTarget) Then Exit Function
  453.             End If
  454.         Else
  455.             ' If it wasn't a whole word search, we're done
  456.             Exit Do
  457.         End If
  458.     Loop
  459.     FindString = iPos
  460. End Function
  461.  
  462. Private Function IsWholeWord(sTarget As String, ByVal iPos As Long, _
  463.                              ByVal cFind As Long) As Boolean
  464.     Dim sChar As String, sSep As String
  465.     sSep = " .,!:?" & sTab & sCrLf
  466.     ' Check character before
  467.     If iPos > 1 Then
  468.         sChar = Mid$(sTarget, iPos - 1, 1)
  469.         If InStr(sSep, sChar) = 0 Then Exit Function
  470.     End If
  471.     ' Check character after
  472.     If iPos < Len(sTarget) - 1 Then
  473.         sChar = Mid$(sTarget, iPos + cFind, 1)
  474.         If InStr(sSep, sChar) = 0 Then Exit Function
  475.     End If
  476.     IsWholeWord = True
  477. End Function
  478.  
  479. ' Basic is one of the few languages where you can't extract a character
  480. ' from or insert a character into a string at a given position without
  481. ' creating another string. These procedures fix that limitation.
  482.  
  483. ' Much faster than AscW(Mid$(sTarget, iPos, 1))
  484. Function CharFromStr(sTarget As String, _
  485.                      Optional ByVal iPos As Long = 1) As Integer
  486.     CopyMemory CharFromStr, ByVal StrPtr(sTarget) + (iPos * 2) - 2, 2
  487. End Function
  488.  
  489. ' Much faster than Mid$(sTarget, iPos, 1) = Chr$(ch)
  490. Sub CharToStr(sTarget As String, ByVal ch As Integer, _
  491.               Optional ByVal iPos As Long = 1)
  492.     CopyMemory ByVal StrPtr(sTarget) + (iPos * 2) - 2, ch, 2
  493. End Sub
  494.  
  495. ' This brute force algorithm should be replaced with the Boyer-Moore
  496. ' algrorithm or some other sophisticated string search code
  497. Function InStrR(Optional vStart As Variant, _
  498.                 Optional vTarget As Variant, _
  499.                 Optional vFind As Variant, _
  500.                 Optional vCompare As Variant) As Long
  501.     If IsMissing(vStart) Then ErrRaise eeMissingParameter
  502.     
  503.     ' Handle missing arguments
  504.     Dim iStart As Long, sTarget As String
  505.     Dim sFind As String, ordCompare As Long
  506.     If VarType(vStart) = vbString Then
  507.         BugAssert IsMissing(vCompare)
  508.         If IsMissing(vTarget) Then ErrRaise eeMissingParameter
  509.         sTarget = vStart
  510.         sFind = vTarget
  511.         iStart = Len(sTarget)
  512.         If IsMissing(vFind) Then
  513.             ordCompare = vbBinaryCompare
  514.         Else
  515.             ordCompare = vFind
  516.         End If
  517.     Else
  518.         If IsMissing(vTarget) Or IsMissing(vFind) Then
  519.             ErrRaise eeMissingParameter
  520.         End If
  521.         sTarget = vTarget
  522.         sFind = vFind
  523.         iStart = vStart
  524.         If IsMissing(vCompare) Then
  525.             ordCompare = vbBinaryCompare
  526.         Else
  527.             ordCompare = vCompare
  528.         End If
  529.     End If
  530.     
  531.     ' Search backward
  532.     Dim cFind As Long, i As Long, f As Long
  533.     cFind = Len(sFind)
  534.     For i = iStart - cFind + 1 To 1 Step -1
  535.         If StrComp(Mid$(sTarget, i, cFind), sFind, ordCompare) = 0 Then
  536.             InStrR = i
  537.             Exit Function
  538.         End If
  539.     Next
  540. End Function
  541.  
  542.  
  543. Function PlayWave(ab() As Byte, Optional Flags As Long = _
  544.                                 SND_MEMORY Or SND_SYNC) As Boolean
  545.     PlayWave = sndPlaySoundAsBytes(ab(0), Flags)
  546. End Function
  547.  
  548. Sub InsertChar(sTarget As String, sChar As String, iPos As Integer)
  549.     BugAssert Len(sChar) = 1        ' Accept characters only
  550.     BugAssert iPos > 0              ' Don't insert before beginning
  551.     BugAssert iPos <= Len(sTarget)  ' Don't insert beyond end
  552.     Mid$(sTarget, iPos, 1) = sChar  ' Do work
  553. End Sub
  554.  
  555. Function LineWrap(sText As String, cMax As Integer)
  556.     Dim s As String, i As Integer, iLast As Integer, c As Integer
  557.     c = Len(sText)
  558.     i = 1
  559.     Do While c
  560.         iLast = i
  561.         i = i + cMax
  562.         Do While Mid$(sText, i, 1) <> sSpace
  563.             i = i - 1
  564.         Loop
  565.         s = s & Mid$(sText, iLast, i - iLast) & sCrLf & "   "
  566.         i = i + 1
  567.     Loop
  568.     LineWrap = s
  569. End Function
  570.  
  571. ' Pascal:    if ch in ['a', 'f', 'g'] then
  572. ' Basic:     If Among(ch, "a", "f", "g") Then
  573. Function Among(vTarget As Variant, ParamArray A() As Variant) As Boolean
  574.     Among = True    ' Assume found
  575.     Dim v As Variant
  576.     For Each v In A()
  577.         If v = vTarget Then Exit Function
  578.     Next
  579.     Among = False
  580. End Function
  581.  
  582. ' Work around limitation of AddressOf
  583. '    Call like this: procVar = GetProc(AddressOf ProcName)
  584. Function GetProc(proc As Long) As Long
  585.     GetProc = proc
  586. End Function
  587.  
  588. Function WordWrap(sText As String, ByVal cMax As Long) As String
  589.     Dim iStart As Long, iEnd As Long, cText As Long, sSep As String
  590.     cText = Len(sText)
  591.     iStart = 1
  592.     iEnd = cMax
  593.     sSep = " " & sTab & sCrLf
  594.     Do While iEnd < cText
  595.         ' Parse back to white space
  596.         Do While InStr(sSep, Mid$(sText, iEnd, 1)) = 0
  597.             iEnd = iEnd - 1
  598.             ' Don't send us text with words longer than the lines!
  599.             If iEnd <= iStart Then
  600.                 WordWrap = sText
  601.                 Exit Function
  602.             End If
  603.         Loop
  604.         WordWrap = WordWrap & Mid$(sText, iStart, iEnd - iStart + 1) & sCrLf
  605.         iStart = iEnd + 1
  606.         iEnd = iStart + cMax
  607.     Loop
  608.     WordWrap = WordWrap + Mid$(sText, iStart)
  609. End Function
  610.  
  611.  
  612. Sub CollectionReplace(n As Collection, vIndex As Variant, _
  613.                       vVal As Variant)
  614.     If VarType(vIndex) = vbString Then
  615.         n.Remove vIndex
  616.         n.Add vVal, vIndex
  617.     Else
  618.         n.Add vVal, , vIndex
  619.         n.Remove vIndex + 1
  620.     End If
  621. End Sub
  622.  
  623. Function GetLabel(sRoot As String) As String
  624.     GetLabel = Dir$(sRoot & "*.*", vbVolume)
  625. End Function
  626.  
  627. Function GetFileBase(sFile As String) As String
  628.     Dim iBase As Long, iExt As Long, s As String
  629.     If sFile = sEmpty Then Exit Function
  630.     s = GetFullPath(sFile, iBase, iExt)
  631.     GetFileBase = Mid$(s, iBase, iExt - iBase)
  632. End Function
  633.  
  634. Function GetFileBaseExt(sFile As String) As String
  635.     Dim iBase As Long, s As String
  636.     If sFile = sEmpty Then Exit Function
  637.     s = GetFullPath(sFile, iBase)
  638.     GetFileBaseExt = Mid$(s, iBase)
  639. End Function
  640.  
  641. Function GetFileExt(sFile As String) As String
  642.     Dim iExt As Long, s As String
  643.     If sFile = sEmpty Then Exit Function
  644.     s = GetFullPath(sFile, , iExt)
  645.     GetFileExt = Mid$(s, iExt)
  646. End Function
  647.  
  648. Function GetFileDir(sFile As String) As String
  649.     Dim iBase As Long, s As String
  650.     If sFile = sEmpty Then Exit Function
  651.     s = GetFullPath(sFile, iBase)
  652.     GetFileDir = Left$(s, iBase - 1)
  653. End Function
  654.  
  655. Function GetFileFullSpec(sFile As String) As String
  656.     If sFile = sEmpty Then Exit Function
  657.     GetFileFullSpec = GetFullPath(sFile)
  658. End Function
  659.  
  660. Function SearchForExe(sName As String) As String
  661.     Dim sSpec As String, asExt(1 To 5) As String, i As Integer
  662.     asExt(1) = ".EXE": asExt(2) = ".COM": asExt(3) = ".PIF":
  663.     asExt(4) = ".BAT": asExt(5) = ".CMD"
  664.     For i = 1 To 5
  665.         sSpec = SearchDirs(sName, asExt(i))
  666.         If sSpec <> sEmpty Then Exit For
  667.     Next
  668.     SearchForExe = sSpec
  669. End Function
  670.  
  671. Function IsExe() As Boolean
  672.     Dim sExe  As String, c As Long
  673.     sExe = String$(255, 0)
  674.     c = GetModuleFileName(hNull, sExe, 255)
  675.     sExe = Left$(sExe, c)
  676.     IsExe = Right$(UCase$(sExe), 7) <> "VB5.EXE"
  677. End Function
  678.  
  679. Function xRight(obj As Object) As Single
  680.     xRight = obj.Left + obj.Width
  681. End Function
  682.  
  683. Function yBottom(obj As Object) As Single
  684.     yBottom = obj.Top + obj.Height
  685. End Function
  686.  
  687. ' Win32 functions with Basic interface
  688.  
  689. ' GetFullPath - Basic version of Win32 API emulation routine. It returns a
  690. ' BSTR, and indexes to the file name, directory, and extension parts of the
  691. ' full name.
  692. '
  693. ' Input:  sFileName - file to be qualified in one of these formats:
  694. '
  695. '              [relpath\]file.ext
  696. '              \[path\]file.ext
  697. '              .\[path\]file.ext
  698. '              d:\[path\]file.ext
  699. '              ..\[path\]file.ext
  700. '              \\server\machine\[path\]file.ext
  701. '          iName - variable to receive file name position
  702. '          iDir - variable to receive directory position
  703. '          iExt - variable to receive extension position
  704. '
  705. ' Return: Full path name, or an empty string on failure
  706. '
  707. ' Errors: Any of the following:
  708. '              ERROR_BUFFER_OVERFLOW      = 111
  709. '              ERROR_INVALID_DRIVE        = 15
  710. '              ERROR_CALL_NOT_IMPLEMENTED = 120
  711. '              ERROR_BAD_PATHNAME         = 161
  712.  
  713.  
  714. Function GetFullPath(sFileName As String, _
  715.                      Optional FilePart As Long, _
  716.                      Optional ExtPart As Long, _
  717.                      Optional DirPart As Long) As String
  718.  
  719.     Dim c As Long, p As Long, sRet As String
  720.     If sFileName = sEmpty Then Exit Function
  721.     
  722.     ' Get the path size, then create string of that size
  723.     sRet = String(cMaxPath, 0)
  724.     c = GetFullPathName(sFileName, cMaxPath, sRet, p)
  725.     If c = 0 Then ApiRaise Err.LastDllError
  726.     BugAssert c <= cMaxPath
  727.     sRet = Left$(sRet, c)
  728.  
  729.     ' Get the directory, file, and extension positions
  730.     GetDirExt sRet, FilePart, DirPart, ExtPart
  731.     GetFullPath = sRet
  732.     
  733. End Function
  734.  
  735. Function GetTempFile(Optional Prefix As String, _
  736.                      Optional PathName As String) As String
  737.     
  738.     If Prefix = sEmpty Then Prefix = sEmpty
  739.     If PathName = sEmpty Then PathName = GetTempDir
  740.     
  741.     Dim sRet As String
  742.     sRet = String(cMaxPath, 0)
  743.     GetTempFileName PathName, Prefix, 0, sRet
  744.     ApiRaiseIf Err.LastDllError
  745.     GetTempFile = GetFullPath(StrZToStr(sRet))
  746. End Function
  747.  
  748. Function GetTempDir() As String
  749.     Dim sRet As String, c As Long
  750.     sRet = String(cMaxPath, 0)
  751.     c = GetTempPath(cMaxPath, sRet)
  752.     If c = 0 Then ApiRaise Err.LastDllError
  753.     GetTempDir = Left$(sRet, c)
  754. End Function
  755.  
  756. Function SearchDirs(sFileName As String, _
  757.                     Optional Ext As String, _
  758.                     Optional Path As String, _
  759.                     Optional FilePart As Long, _
  760.                     Optional ExtPart As Long, _
  761.                     Optional DirPart As Long) As String
  762.  
  763.     Dim p As Long, c As Long, sRet As String
  764.  
  765.     If sFileName = sEmpty Then ApiRaise ERROR_INVALID_PARAMETER
  766.  
  767.     ' Handle missing or invalid extension or path
  768.     If Ext = sEmpty Then Ext = sNullStr
  769.     If Path = sEmpty Then Path = sNullStr
  770.     
  771.     ' Get the file (treating empty strings as NULL pointers)
  772.     sRet = String$(cMaxPath, 0)
  773.     c = SearchPath(Path, sFileName, Ext, cMaxPath, sRet, p)
  774.     If c = 0 Then
  775.         If Err.LastDllError = ERROR_FILE_NOT_FOUND Then Exit Function
  776.         ApiRaise Err.LastDllError
  777.     End If
  778.     BugAssert c <= cMaxPath
  779.     sRet = Left$(sRet, c)
  780.  
  781.     ' Get the directory, file, and extension positions
  782.     GetDirExt sRet, FilePart, DirPart, ExtPart
  783.     SearchDirs = sRet
  784.    
  785. End Function
  786.  
  787. Private Sub GetDirExt(sFull As String, iFilePart As Long, _
  788.                       iDirPart As Long, iExtPart As Long)
  789.  
  790.     Dim iDrv As Integer, i As Integer, cMax As Integer
  791.     cMax = Len(sFull)
  792.  
  793.     iDrv = Asc(UCase$(Left$(sFull, 1)))
  794.  
  795.     ' If in format d:\path\name.ext, return 3
  796.     If iDrv <= 90 Then                          ' Less than Z
  797.         If iDrv >= 65 Then                      ' Greater than A
  798.             If Mid$(sFull, 2, 1) = ":" Then     ' Second character is :
  799.                 If Mid$(sFull, 3, 1) = "\" Then ' Third character is \
  800.                     iDirPart = 3
  801.                 End If
  802.             End If
  803.         End If
  804.     Else
  805.  
  806.         ' If in format \\machine\share\path\name.ext, return position of \path
  807.         ' First and second character must be \
  808.         If iDrv <> 92 Then ApiRaise ERROR_BAD_PATHNAME
  809.         If Mid$(sFull, 2, 1) <> "\" Then ApiRaise ERROR_BAD_PATHNAME
  810.  
  811.         Dim fFirst As Boolean
  812.         i = 3
  813.         Do
  814.             If Mid$(sFull, i, 1) = "\" Then
  815.                 If Not fFirst Then
  816.                     fFirst = True
  817.                 Else
  818.                     iDirPart = i
  819.                     Exit Do
  820.                 End If
  821.             End If
  822.             i = i + 1
  823.         Loop Until i = cMax
  824.     End If
  825.  
  826.     ' Start from end and find extension
  827.     iExtPart = cMax + 1       ' Assume no extension
  828.     fFirst = False
  829.     Dim sChar As String
  830.     For i = cMax To iDirPart Step -1
  831.         sChar = Mid$(sFull, i, 1)
  832.         If Not fFirst Then
  833.             If sChar = "." Then
  834.                 iExtPart = i
  835.                 fFirst = True
  836.             End If
  837.         End If
  838.         If sChar = "\" Then
  839.             iFilePart = i + 1
  840.             Exit For
  841.         End If
  842.     Next
  843.     Exit Sub
  844. FailGetDirExt:
  845.     iFilePart = 0
  846.     iDirPart = 0
  847.     iExtPart = 0
  848. End Sub
  849.  
  850. #If fComponent Then
  851. ' Seed the component's copy of the random number generator
  852. Sub CoreRandomize(Optional Number As Long)
  853.     Randomize Number
  854. End Sub
  855.  
  856. Function CoreRnd(Optional Number As Long)
  857.     CoreRnd = Rnd(Number)
  858. End Function
  859. #End If
  860.  
  861. ' GetNextLine returns a line from a string, where a "line" is all characters
  862. ' up to and including a carriage return + line feed. GetNextLine
  863. ' works the same way as GetToken. The first call to GetNextLine
  864. ' should pass the string to parse; subsequent calls should pass
  865. ' an empty string. GetNextLine returns an empty string after all lines
  866. ' have been read from the source string.
  867. Function GetNextLine(Optional sSource As String) As String
  868.     Static sSave As String, iStart As Long, cSave As Long
  869.     Dim iEnd As Long
  870.     
  871.     ' Initialize GetNextLine
  872.     If (sSource <> sEmpty) Then
  873.         iStart = 1
  874.         sSave = sSource
  875.         cSave = Len(sSave)
  876.     Else
  877.         If sSave = sEmpty Then Exit Function
  878.     End If
  879.     
  880.     ' iStart points to first character after the previous sCrLf
  881.     iEnd = InStr(iStart, sSave, sCrLf)
  882.     
  883.     If iEnd > 0 Then
  884.         ' Return line
  885.         GetNextLine = Mid$(sSave, iStart, iEnd - iStart + 2)
  886.         iStart = iEnd + 2
  887.         If iStart > cSave Then sSave = sEmpty
  888.     Else
  889.         ' Return remainder of string as a line
  890.         GetNextLine = Mid$(sSave, iStart) & sCrLf
  891.         sSave = sEmpty
  892.     End If
  893. End Function
  894.  
  895. ' RTrimLine strips off trailing carriage return + line feed
  896. Function RTrimLine(sLine As String) As String
  897.     If Right$(sLine, 2) = sCrLf Then
  898.         RTrimLine = Left$(sLine, Len(sLine) - 2)
  899.     Else
  900.         RTrimLine = sLine
  901.     End If
  902. End Function
  903.  
  904.  
  905.  
  906.